home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / generic / primtype.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  8.9 KB  |  266 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: primtype.lisp,v 1.6 91/11/09 02:39:50 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: primtype.lisp,v 1.6 91/11/09 02:39:50 wlott Exp $
  15. ;;;
  16. ;;; This file contains the machine independent aspects of the object
  17. ;;; representation and primitive types.
  18. ;;;
  19. ;;; Written by William Lott.
  20. ;;;
  21. (in-package "VM")
  22.  
  23.  
  24. ;;;; Primitive Type Definitions
  25.  
  26. ;;; *Anything*
  27. ;;; 
  28. (def-primitive-type t (descriptor-reg))
  29. (defvar *any-primitive-type* (primitive-type-or-lose 't))
  30. (setf (backend-any-primitive-type *target-backend*) *any-primitive-type*)
  31.  
  32. ;;; Primitive integer types that fit in registers.
  33. ;;;
  34. (def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
  35.   :type (unsigned-byte 29))
  36. (def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
  37.   :type (unsigned-byte 31))
  38. (def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
  39.   :type (unsigned-byte 32))
  40. (def-primitive-type fixnum (any-reg signed-reg)
  41.   :type (signed-byte 30))
  42. (def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
  43.   :type (signed-byte 32))
  44.  
  45. (defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
  46.  
  47. (def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
  48. (def-primitive-type-alias unsigned-num (:or unsigned-byte-32
  49.                         unsigned-byte-31
  50.                         positive-fixnum))
  51. (def-primitive-type-alias signed-num (:or signed-byte-32
  52.                       fixnum
  53.                       unsigned-byte-31
  54.                       positive-fixnum))
  55.  
  56. ;;; Other primitive immediate types.
  57. (def-primitive-type base-char (base-char-reg any-reg))
  58.  
  59. ;;; Primitive pointer types.
  60. ;;; 
  61. (def-primitive-type function (descriptor-reg))
  62. (def-primitive-type list (descriptor-reg))
  63. (def-primitive-type structure (descriptor-reg))
  64.  
  65. ;;; Primitive other-pointer number types.
  66. ;;; 
  67. (def-primitive-type bignum (descriptor-reg))
  68. (def-primitive-type ratio (descriptor-reg))
  69. (def-primitive-type complex (descriptor-reg))
  70. (def-primitive-type single-float (single-reg descriptor-reg))
  71. (def-primitive-type double-float (double-reg descriptor-reg))
  72.  
  73. ;;; Primitive other-pointer array types.
  74. ;;; 
  75. (def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
  76. (def-primitive-type simple-bit-vector (descriptor-reg))
  77. (def-primitive-type simple-vector (descriptor-reg))
  78. (def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
  79.   :type (simple-array (unsigned-byte 2) (*)))
  80. (def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
  81.   :type (simple-array (unsigned-byte 4) (*)))
  82. (def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
  83.   :type (simple-array (unsigned-byte 8) (*)))
  84. (def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
  85.   :type (simple-array (unsigned-byte 16) (*)))
  86. (def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
  87.   :type (simple-array (unsigned-byte 32) (*)))
  88. (def-primitive-type simple-array-single-float (descriptor-reg)
  89.   :type (simple-array single-float (*)))
  90. (def-primitive-type simple-array-double-float (descriptor-reg)
  91.   :type (simple-array double-float (*)))
  92.  
  93. ;;; Note: The complex array types are not inclueded, 'cause it is pointless to
  94. ;;; restrict VOPs to them.
  95.  
  96. ;;; Other primitive other-pointer types.
  97. ;;; 
  98. (def-primitive-type system-area-pointer (sap-reg descriptor-reg))
  99. (def-primitive-type weak-pointer (descriptor-reg))
  100.  
  101. ;;; Random primitive types that don't exist at the LISP level.
  102. ;;; 
  103. (def-primitive-type random (non-descriptor-reg) :type nil)
  104. (def-primitive-type interior (interior-reg) :type nil)
  105. (def-primitive-type catch-block (catch-block) :type nil)
  106.  
  107.  
  108.  
  109.  
  110. ;;;; Primitive-type-of and friends.
  111.  
  112. ;;; Primitive-Type-Of  --  Interface
  113. ;;;
  114. ;;;    Return the most restrictive primitive type that contains Object.
  115. ;;;
  116. (def-vm-support-routine primitive-type-of (object)
  117.   (let ((type (ctype-of object)))
  118.     (cond ((not (member-type-p type)) (primitive-type type))
  119.       ((equal (member-type-members type) '(nil))
  120.        (primitive-type-or-lose 'list *backend*))
  121.       (t
  122.        *any-primitive-type*))))
  123.  
  124. ;;; 
  125. (defvar *simple-array-primitive-types*
  126.   '((base-char . simple-string)
  127.     (string-char . simple-string)
  128.     (bit . simple-bit-vector)
  129.     ((unsigned-byte 2) . simple-array-unsigned-byte-2)
  130.     ((unsigned-byte 4) . simple-array-unsigned-byte-4)
  131.     ((unsigned-byte 8) . simple-array-unsigned-byte-8)
  132.     ((unsigned-byte 16) . simple-array-unsigned-byte-16)
  133.     ((unsigned-byte 32) . simple-array-unsigned-byte-32)
  134.     (single-float . simple-array-single-float)
  135.     (double-float . simple-array-double-float)
  136.     (t . simple-vector))
  137.   "An a-list for mapping simple array element types to their
  138.   corresponding primitive types.")
  139.  
  140.  
  141. ;;; Return the primitive type corresponding to a type descriptor
  142. ;;; structure. The second value is true when the primitive type is
  143. ;;; exactly equivalent to the argument Lisp type.
  144. ;;;
  145. ;;; In a bootstrapping situation, we should be careful to use the
  146. ;;; correct values for the system parameters.
  147. ;;;
  148. ;;; We need an aux function because we need to use both def-vm-support-routine
  149. ;;; and defun-cached.
  150. ;;; 
  151. (def-vm-support-routine primitive-type (type)
  152.   (primitive-type-aux type))
  153. ;;;
  154. (defun-cached (primitive-type-aux
  155.            :hash-function (lambda (x)
  156.                 (logand (cache-hash-eq x) #x1FF))
  157.            :hash-bits 9
  158.            :values 2
  159.            :default (values nil :empty))
  160.           ((type eq))
  161.   (declare (type ctype type))
  162.   (macrolet ((any () '(values *any-primitive-type* nil))
  163.          (exactly (type)
  164.            `(values (primitive-type-or-lose ',type *backend*) t))
  165.          (part-of (type)
  166.            `(values (primitive-type-or-lose ',type *backend*) nil)))
  167.     (etypecase type
  168.       (numeric-type
  169.        (let ((lo (numeric-type-low type))
  170.          (hi (numeric-type-high type)))
  171.      (case (numeric-type-complexp type)
  172.        (:real
  173.         (case (numeric-type-class type)
  174.           (integer
  175.            (cond ((and hi lo)
  176.               (dolist (spec
  177.                    '((positive-fixnum 0 #.(1- (ash 1 29)))
  178.                  (unsigned-byte-31 0 #.(1- (ash 1 31)))
  179.                  (unsigned-byte-32 0 #.(1- (ash 1 32)))
  180.                  (fixnum #.(ash -1 29) #.(1- (ash 1 29)))
  181.                  (signed-byte-32 #.(ash -1 31)
  182.                          #.(1- (ash 1 31))))
  183.                    (if (or (< hi (ash -1 29))
  184.                        (> lo (1- (ash 1 29))))
  185.                    (part-of bignum)
  186.                    (any)))
  187.             (let ((type (car spec))
  188.                   (min (cadr spec))
  189.                   (max (caddr spec)))
  190.               (when (<= min lo hi max)
  191.                 (return (values (primitive-type-or-lose type
  192.                                     *backend*)
  193.                         (and (= lo min) (= hi max))))))))
  194.              ((or (and hi (< hi most-negative-fixnum))
  195.               (and lo (> lo most-positive-fixnum)))
  196.               (part-of bignum))
  197.              (t
  198.               (any))))
  199.           (float
  200.            (let ((exact (and (null lo) (null hi))))
  201.          (case (numeric-type-format type)
  202.            ((short-float single-float)
  203.             (values (primitive-type-or-lose 'single-float *backend*)
  204.                 exact))
  205.            ((double-float long-float)
  206.             (values (primitive-type-or-lose 'double-float *backend*)
  207.                 exact))
  208.            (t
  209.             (any)))))
  210.           (t
  211.            (any))))
  212.        (:complex
  213.         (part-of complex))
  214.        (t
  215.         (any)))))
  216.       (array-type
  217.        (if (array-type-complexp type)
  218.        (any)
  219.        (let* ((dims (array-type-dimensions type))
  220.           (etype (array-type-specialized-element-type type))
  221.           (type-spec (type-specifier etype))
  222.           (ptype (cdr (assoc type-spec *simple-array-primitive-types*
  223.                      :test #'equal))))
  224.          (if (and (consp dims) (null (rest dims)) ptype)
  225.          (values (primitive-type-or-lose ptype *backend*)
  226.              (eq (first dims) '*))
  227.          (any)))))
  228.       (union-type
  229.        (if (type= type (specifier-type 'list))
  230.        (exactly list)
  231.        (let ((types (union-type-types type)))
  232.          (multiple-value-bind (res exact)
  233.                   (primitive-type (first types))
  234.            (dolist (type (rest types) (values res exact))
  235.          (multiple-value-bind (ptype ptype-exact)
  236.                       (primitive-type type)
  237.            (unless ptype-exact (setq exact nil))
  238.            (unless (eq ptype res)
  239.              (return (any)))))))))
  240.       (member-type
  241.        (let* ((members (member-type-members type))
  242.           (res (primitive-type-of (first members))))
  243.      (dolist (mem (rest members) (values res nil))
  244.        (unless (eq (primitive-type-of mem) res)
  245.          (return (values *any-primitive-type* nil))))))
  246.       (named-type
  247.        (case (named-type-name type)
  248.      ((t bignum ratio complex function structure
  249.          system-area-pointer weak-pointer)
  250.       (values (primitive-type-or-lose (named-type-name type) *backend*) t))
  251.      ((character base-char string-char)
  252.       (exactly base-char))
  253.      (standard-char
  254.       (part-of base-char))
  255.      (cons
  256.       (part-of list))
  257.      (t
  258.       (any))))
  259.       (function-type
  260.        (exactly function))
  261.       (structure-type
  262.        (part-of structure))
  263.       (ctype
  264.        (any)))))
  265.  
  266.